VERSION 5.00
Begin VB.UserControl Button2003 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   DefaultCancel   =   -1  'True
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   KeyPreview      =   -1  'True
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "Button2003.ctx":0000
   Begin VB.Timer t1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   840
      Top             =   1680
   End
End
Attribute VB_Name = "Button2003"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private cap As String, en As Boolean
Private xp1 As Boolean, xp2 As Boolean
Private ct As Boolean, bc As Long, bs As Long
Private fnt As StdFont, symb As New StdFont
Private pic As StdPicture
Private sp As Long, cd As Boolean
Private gn As String
Private dr As Boolean

Private uw As Long, uh As Long
Private foc As Boolean, hl As Long
Private hlx As Long, hly As Long

Private bm As New cAlphaDibSection
Private bmTmp As New cAlphaDibSection
Private bm1 As New cAlphaDibSection
Private bm2 As New cAlphaDibSection
Private prc As New cImageProcessDIB

Private lTIme As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long

Public Enum enumButtonStyle2003
 bs2003_Normal = 0
 bs2003_Check = 1
 bs2003_Option = 2
 bs2003_OptionNullable = 3
End Enum

Event Click()

Public Property Get Caption() As String
Caption = cap
End Property

Public Property Let Caption(ByVal s As String)
cap = s
UserControl.AccessKeys = GetHotKey(s)
Redraw
End Property

Public Property Get TextCenter() As Boolean
TextCenter = ct
End Property

Public Property Let TextCenter(ByVal b As Boolean)
ct = b
Redraw
End Property

Public Property Get Enable() As Boolean
Enable = en
End Property

Public Property Let Enable(ByVal b As Boolean)
en = b
Redraw
End Property

Public Property Get Office2003Style() As Boolean
Office2003Style = xp1
End Property

Public Property Let Office2003Style(ByVal b As Boolean)
xp1 = b
Redraw
End Property

Public Property Get GradientBackground() As Boolean
GradientBackground = xp2
End Property

Public Property Let GradientBackground(ByVal b As Boolean)
xp2 = b
Redraw
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = bc
End Property

Public Property Let BackColor(ByVal n As OLE_COLOR)
bc = n
Redraw
End Property

Public Property Get Font() As StdFont
Set Font = fnt
End Property

Public Property Set Font(obj As StdFont)
Set fnt = obj
Redraw
End Property

Public Property Get Picture() As StdPicture
Set Picture = pic
End Property

Public Property Set Picture(obj As StdPicture)
Set pic = obj
Redraw
End Property

Public Property Get Style() As enumButtonStyle2003
Style = bs
End Property

Public Property Let Style(ByVal n As enumButtonStyle2003)
bs = n
Redraw
End Property

Private Sub t1_Timer()
Dim r As RECT, p As POINTAPI
GetCursorPos p
If hl > 0 Then
 If WindowFromPoint(p.x, p.y) <> UserControl.hWnd Then
  hl = 0
  'lTime = 0
  Redraw True
  't1.Enabled = False
 End If
End If
Select Case hl
Case 0
 If lTIme > 0 Then
  lTIme = lTIme - 1
  bm.PaintPicture bm1.hDC
  bmTmp.AlphaPaintPicture bm1.hDC, , , , , , , lTIme * 15, False
  bm1.PaintPicture UserControl.hDC
 Else
  t1.Enabled = False
 End If
Case 1
 If lTIme < 17 Then
  lTIme = lTIme + 1
  bmTmp.PaintPicture bm1.hDC
  bm.AlphaPaintPicture bm1.hDC, , , , , , , lTIme * 15, False
  bm1.PaintPicture UserControl.hDC
 End If
Case 2
 If lTIme < 17 Then
  lTIme = lTIme + 1
  bmTmp.PaintPicture bm1.hDC
  bm.AlphaPaintPicture bm1.hDC, , , , , , , lTIme * 15, False
  bm1.PaintPicture UserControl.hDC
 End If
End Select
End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
fClick
End Sub

Private Sub UserControl_Click()
If hlx > sp And hly > sp And hlx < uw - sp And hly < uh - sp Then fClick
End Sub

Private Sub fClick()
If en Then
 'internal
 Select Case bs
 Case 1
  cd = Not cd
  Redraw
 Case 2, 3
  If cd Then
   If bs = 3 Then
    cd = False
    Redraw
   End If
  Else
   Checked = True
  End If
 End Select
 'raise event
 RaiseEvent Click
End If
End Sub

Private Sub UserControl_GotFocus()
foc = True
Redraw
End Sub

Private Sub UserControl_Initialize()
symb.Name = "Webdings"
UserControl_Resize
End Sub

Private Sub UserControl_InitProperties()
On Error Resume Next
cap = UserControl.Extender.Name
en = True
xp1 = True
ct = True
Set fnt = UserControl.Font
bc = vbButtonFace
sp = 2
dr = True
Redraw
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeySpace, vbKeyReturn
 If hl <> 2 Then
  hl = 2
  Redraw
 End If
End Select
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeySpace, vbKeyReturn
 hl = 0
 Redraw
 fClick
End Select
End Sub

Private Sub UserControl_LostFocus()
foc = False
Redraw
End Sub

Private Sub UserControl_MouseDown(button As Integer, Shift As Integer, x As Single, y As Single)
If hl = 1 Then
 hl = 2
 lTIme = 0
 Redraw True
End If
End Sub

Private Sub UserControl_MouseMove(button As Integer, Shift As Integer, x As Single, y As Single)
If x > sp And y > sp And x < uw - sp And y < uh - sp And en Then
 If hl = 0 Then
  hl = 1
  Redraw True
  t1.Enabled = True
 End If
ElseIf hl > 0 Then
 hl = 0
 Redraw True
End If
End Sub

Private Sub UserControl_MouseUp(button As Integer, Shift As Integer, x As Single, y As Single)
hlx = x
hly = y
If hl = 2 Then
 hl = 1
 Redraw
End If
End Sub

Private Sub UserControl_Paint()
Dim r As RECT
bm.PaintPicture UserControl.hDC
'////////draw focus rect
r.Left = sp * 2
r.Top = sp * 2
r.Right = uw - sp * 2
r.Bottom = uh - sp * 2
If foc And en And dr Then DrawFocusRect UserControl.hDC, r
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
On Error Resume Next
With PropBag
 cap = .ReadProperty("Caption", UserControl.Extender.Name)
 en = .ReadProperty("Enable", True)
 xp1 = .ReadProperty("Office2003Style", True)
 xp2 = .ReadProperty("GradientBackground", False)
 ct = .ReadProperty("TextCenter", True)
 bc = .ReadProperty("BackColor", vbButtonFace)
 Set fnt = .ReadProperty("Font", UserControl.Font)
 Set pic = .ReadProperty("Picture", Nothing)
 bs = .ReadProperty("Style", 0)
 sp = .ReadProperty("ButtonSpace", 2)
 cd = .ReadProperty("Checked", False)
 gn = .ReadProperty("GroupName", "")
 dr = .ReadProperty("ShowFocusRect", True)
End With
UserControl.AccessKeys = GetHotKey(cap)
Redraw
End Sub

Private Sub UserControl_Resize()
uw = UserControl.ScaleWidth
uh = UserControl.ScaleHeight
bm.Create uw, uh
bmTmp.Create uw, uh
bm1.Create uw, uh
Redraw
End Sub

Private Sub Redraw(Optional ByVal b As Boolean)
Dim r As RECT, r1 As RECT, w As Long, w2 As Long, h As Long
Dim x As Long, clr As Long
Dim hBr As Long
'////////test ???
bm.PaintPicture bmTmp.hDC
'////////draw background
r.Right = uw
r.Bottom = uh
If xp1 And xp2 Then
 GradientFillRect bm.hDC, r, &HFBE3D1, &HE3AB84, GRADIENT_FILL_RECT_V
Else
 hBr = CreateSolidBrush(TranslateColor(bc))
 FillRect bm.hDC, r, hBr
 DeleteObject hBr
End If
'////////calc size
DrawTextB bm.hDC, cap, fnt, 0, 0, w, 16, DT_CALCRECT Or DT_SINGLELINE
w2 = 16
h = 15
If Not pic Is Nothing Then
 bm2.CreateFromPicture pic
 w = w + bm2.Width + 8
 If w2 < bm2.Width + 4 Then w2 = bm2.Width + 4
 If h < bm2.Height + 4 Then h = bm2.Height + 4
ElseIf bs > 0 Then
 w = w + w2 + 2
Else
 w2 = 0
End If
If ct Then
 x = (uw - w) \ 2
Else
 x = sp * 3
End If
'////////make sure the text color
If hl > 0 Then
 clr = &H800000
ElseIf en Then
 clr = vbBlack
ElseIf xp1 And xp2 Then
 clr = &H9B8B72
Else
 clr = &H808080
End If
'////////icon and highlight
r.Left = sp
r.Top = sp
r.Right = uw - sp
r.Bottom = uh - sp
'face2003 highlight
If hl > 0 And xp1 Then
 If hl = 2 Then 'pressed
  GradientFillRect bm.hDC, r, &H5586F8, &HA37D2, GRADIENT_FILL_RECT_V
 Else
  GradientFillRect bm.hDC, r, &HD0FCFD, &H9DE0FD, GRADIENT_FILL_RECT_V
 End If
 hBr = CreateSolidBrush(&H800000)
 FrameRect bm.hDC, r, hBr
 DeleteObject hBr
End If
'draw checked
r1.Left = x
r1.Top = (uh - h) \ 2
r1.Right = x + w2
r1.Bottom = r1.Top + h
If bs > 0 And pic Is Nothing Then x = r1.Right
If cd And bs > 0 Then
 If xp1 Then
  If hl > 0 Then
   GradientFillRect bm.hDC, r1, &H5586F8, &HA37D2, GRADIENT_FILL_RECT_V
  Else
   GradientFillRect bm.hDC, r1, &H7DDDFA, &H4EBCF5, GRADIENT_FILL_RECT_V
  End If
  hBr = CreateSolidBrush(&H800000)
 Else
  hBr = CreateSolidBrush(&H800000)
  FillRect bm1.hDC, r1, hBr
  DeleteObject hBr
  bm1.AlphaPaintPicture bm.hDC, r1.Left, r1.Top, r1.Right - r1.Left, r1.Bottom - r1.Top, _
  r1.Left, r1.Top, 64, False
  hBr = CreateSolidBrush(&HC56A31)
 End If
 FrameRect bm.hDC, r1, hBr
 DeleteObject hBr
 If pic Is Nothing Then
  If bs = 1 Then
   symb.Size = 16
   DrawTextB bm.hDC, "a", symb, r1.Left + 1, r1.Top - 1, _
r1.Right - r1.Left, r1.Bottom - r1.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr, , True 'checkbox
  Else
   symb.Size = 12
   DrawTextB bm.hDC, "=", symb, r1.Left - 1, r1.Top - 1, _
r1.Right - r1.Left, r1.Bottom - r1.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr, , True 'option
  End If
 End If
End If
'draw icon
If Not pic Is Nothing Then
 If Not en Then
  prc.GrayScale bm2
 ElseIf xp1 And hl > 0 Then
  prc.HueSaturation bm2, 0, 2, 0.1
 End If
 TransBltA bm.hDC, x + 2, (uh - bm2.Height) \ 2 + 1, bm2.Width, bm2.Height, bm2.hDC, _
 0, 0, bm2.Width, bm2.Height, GetPixel(bm2.hDC, 0, 0)
 x = x + bm2.Width
End If
'facexp highlight
If hl > 0 And Not xp1 Then
 hBr = CreateSolidBrush(vbBlue)
 FillRect bm1.hDC, r, hBr
 DeleteObject hBr
 bm1.AlphaPaintPicture bm.hDC, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, _
 r.Left, r.Top, hl * 32, False
 hBr = CreateSolidBrush(&HC56A31)
 FrameRect bm.hDC, r, hBr
 DeleteObject hBr
End If
'////////draw text
If ct Then w2 = w2 \ 2 Else w2 = x + 2
DrawTextB bm.hDC, cap, fnt, w2 + 1, 0, uw, uh, DT_VCENTER Or DT_SINGLELINE Or IIf(ct, 1, 0), clr, , True
'////////ok!
If Not b Then UserControl_Paint
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
 .WriteProperty "Caption", cap, UserControl.Name
 .WriteProperty "Enable", en, True
 .WriteProperty "Office2003Style", xp1, True
 .WriteProperty "GradientBackground", xp2, False
 .WriteProperty "TextCenter", ct, True
 .WriteProperty "BackColor", bc, vbButtonFace
 .WriteProperty "Font", fnt, UserControl.Font
 .WriteProperty "Picture", pic, Nothing
 .WriteProperty "Style", bs, 0
 .WriteProperty "ButtonSpace", sp, 2
 .WriteProperty "Checked", cd, False
 .WriteProperty "GroupName", gn, ""
 .WriteProperty "ShowFocusRect", dr, True
End With
End Sub

Public Property Get ButtonSpace() As Long
ButtonSpace = sp
End Property

Public Property Let ButtonSpace(ByVal n As Long)
sp = n
Redraw
End Property

Public Property Get Checked() As Boolean
Checked = cd
End Property

Public Property Let Checked(ByVal b As Boolean)
On Error Resume Next
Dim btn As Object
If b And Not cd And bs > 1 Then
 For Each btn In UserControl.Parent
  If Not btn Is Nothing Then
   If TypeName(btn) = "Button2003" Then
    If Not btn Is Me Then
     If bs = btn.Style And btn.Checked And gn = btn.GroupName Then
      btn.Checked = False
     End If
    End If
   End If
  End If
 Next btn
End If
cd = b
Redraw
End Property

Public Property Get GroupName() As String
GroupName = gn
End Property

Public Property Let GroupName(ByVal s As String)
gn = s
End Property

Public Property Get ShowFocusRect() As Boolean
ShowFocusRect = dr
End Property

Public Property Let ShowFocusRect(ByVal b As Boolean)
dr = b
UserControl_Paint
End Property
